#lang swindle

(require "swindle.ss")
(require* "private.ss")
(require (prefix xml: xml/xml))
(provide (all-from xml/xml))
(require (only srfi/1 lset=))
(require (only scheme/runtime-path define-runtime-path))
(require* mzlib/pretty)
(provide (all-defined))

(define-runtime-path client.xsd "client.xsd")

(xml:read-comments #t)
(xml:xexpr-drop-empty-attributes #t)
(define xml-input (with-input-from-file client.xsd xml:read-xml))

(define (xexpr-element-values xexpr)
  (if (null? (cdr xexpr))
      (values (car xexpr) null null)
      (let ((attrs (cadr xexpr)))
        (if (or (null? attrs) (and (pair? attrs) (pair? (car attrs))))
            (values (car xexpr) attrs (cddr xexpr))
            (values (car xexpr) null (cdr xexpr))))))

(define (same-xexpr? xexpr1 xexpr2)
  (cond ((null? xexpr1)
         (null? xexpr2))
        ((pair? xexpr1)
         (let-values (((tag1 attrs1 content1) (xexpr-element-values xexpr1))
                      ((tag2 attrs2 content2) (xexpr-element-values xexpr2)))
           (and (eq? tag1 tag2)
                (lset= equal? attrs1 attrs2)
                (equal? content1 content2))))
        (else
         (equal? xexpr1 xexpr2))))

(define dom #f)
(define input #f)
(define parser #f)
(define doc #f)
(define xml-output #f)
(define doc2 #f)
(define doc3 #f)

(define (test1)
  (set! dom (dom-implementation *the-dom-implementation-registry* "LS"))
  (set! input (create-ls-input dom))
  (set! (system-id input)
	(as <dom-string> (concat "file:" (path->string client.xsd))))
  (set! parser (create-ls-parser dom *mode-synchronous*))
  (set! doc (parse parser input))
  (set! xml-output (dom->xml doc))
  (if (same-xexpr? (xml:xml->xexpr (xml:document-element xml-input))
                   (xml:xml->xexpr (xml:document-element xml-output)))
      (echo 'OK)
      (begin (xml:write-xml xml-output) (newline)))
  (set! doc2 (xml->dom xml-output))
  (if (equals? doc doc2)
      (echo 'OK)
      (begin (xml:write-xml xml-output) (newline)))
;    (set! doc3 (clone-node doc #t))
;    (if (equals? doc doc3)
;	(echo 'OK)
;	(begin (xml:write-xml (dom->xml doc3)) (newline)))
  )

(define root #f)
(define text #f)
(define text2 #f)
(define middle #f)

(define (test2)
  (set! dom (dom-implementation *the-dom-implementation-registry* "XML"))
  (set! doc (create-document dom #f "root" #f))
  (set! root (document-element doc))
  (set! text (append-child! root (create-text-node doc "foobar")))
  (pretty-print (dom->xexpr root))
  (set! text2 (split-text! text 3))
  (pretty-print (dom->xexpr root))
  (set! middle (insert-before! root (create-element doc "blah") text2))
  (pretty-print (dom->xexpr root))
  (normalize! root)
  (pretty-print (dom->xexpr root))
  (remove-child! root middle)
  (pretty-print (dom->xexpr root))
  (normalize! root)
  (pretty-print (dom->xexpr root))
  )

(defmethod (pretty-print-node-list (nodes <node-list>))
  (do-sequence (node nodes)
    (pretty-print (dom->xexpr node))))

(define seqs #f)
(define seqs-ns #f)

(define (test3)
  (set! seqs (elements-by-tag-name doc "xs:sequence"))
  (pretty-print-node-list seqs)
  (set! seqs-ns (elements-by-tag-name-ns
                 doc "http://www.w3.org/2001/XMLSchema" "sequence"))
  (if (equals? seqs seqs-ns)
      (echo 'OK)
      (pretty-print-node-list seqs-ns))
  )

(defmethod (test)
  (test2)
  (test1)
  (test3)
  )

